home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / predef1.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  41.2 KB  |  1,808 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /*    +---------------------------------------------------+
  10.       |                                                   |
  11.       |          I N T E R P     P R E D E F S            |
  12.       |                  (C Version)                      |
  13.       |                                                   |
  14.       |   Adapted From Low Level SETL version written by  |
  15.       |                                                   |
  16.       |                  Monte Zweben                     |
  17.       |               Philippe Kruchten                   |
  18.       |               Jean-Pierre Rosen                   |
  19.       |                                                   |
  20.       |    Original High Level SETL version written by    |
  21.       |                                                   |
  22.       |                   Clint Goss                      |
  23.       |               Tracey M. Siesser                   |
  24.       |               Bernard D. Banner                   |
  25.       |               Stephen C. Bryant                   |
  26.       |                  Gerry Fisher                     |
  27.       |                                                   |
  28.       |              C version written by                 |
  29.       |                                                   |
  30.       |               Robert B. K. Dewar                  |
  31.       |                                                   |
  32.       +---------------------------------------------------+ */
  33.  
  34. /* This module contains routines for the implementation of some of
  35.  * the predefined Ada packages and routines, namely SEQUENTIAL_IO,
  36.  * DIRECT_IO, TEXT_IO, and CALENDAR. Part 1 contains the PREDEF
  37.  * routine which executes a predefined operation.
  38. */
  39.  
  40. #include <stdlib.h>
  41. #include <setjmp.h>
  42. #include <string.h>
  43. #include "ipredef.h"
  44. #include "intbprots.h"
  45. #include "intcprots.h"
  46. #include "predefprots.h"
  47.  
  48. /*
  49.  * Environment variable to save stack pointer for PREDEF_RAISE. On entry to
  50.  * PREDEF, raise_env saves the stack environment (using set_jmp). If an Ada
  51.  * exception is signalled, then the PREDEF_RAISE routine raises the exception
  52.  * using the usual raise procedure, and then exits directly at the top level
  53.  * of the PREDEF procedure, using longjmp.
  54.  */
  55.  
  56. jmp_buf raise_env;
  57.  
  58. static int string_offset(int *);
  59.  
  60. /* Procedure called by main interpreter to execute predefined operation. The
  61.  * operation code has been read from the code stream and is passed as the
  62.  * parameter. The remaining parameters are stacked as needed.
  63. */
  64.  
  65. void predef()                                /*;predef*/
  66. {
  67.     /* This procedure handles all predefined operations. It is passed a marker
  68.      * which determines the operation to be performed. The formal parameters of
  69.      * the original call have been evaluted onto CURSTACK, but must not be
  70.      * popped as then will be discarded by the code. In the case of generic
  71.      * procedures, the type template address is pushed on the parameters AND
  72.      *  MUST BE POPPED!
  73.      */
  74.  
  75.     /* First capture environment for use by PREDEF_RAISE */
  76.  
  77.     if (setjmp(raise_env))
  78.         return;
  79.  
  80.     /* Switch on the operation code */
  81.  
  82.     switch(operation) {
  83.  
  84.  
  85.         /* 14.2.1  FILE MANAGEMENT */
  86.  
  87.  
  88.         /* SEQUENTIAL_IO:                                     */
  89.         /* procedure CREATE(FILE  : in out FILE_TYPE;         */
  90.         /*                  MODE  : in FILE_MODE := OUT_FILE; */
  91.         /*                  NAME  : in STRING    := "";       */
  92.         /*                  FORM  : in STRING    := "");      */
  93.  
  94.     case P_SIO_CREATE:
  95.         {
  96.             open_seq_io('C');
  97.             break;
  98.         }
  99.  
  100.  
  101.         /* DIRECT_IO:                                          */
  102.         /* procedure CREATE(FILE : in out FILE_TYPE;           */
  103.         /*                  MODE : in FILE_MODE := INOUT_FILE; */
  104.         /*                  NAME : in STRING    := "";         */
  105.         /*                  FORM : in STRING    := "");        */
  106.  
  107.     case P_DIO_CREATE:
  108.         {
  109.             open_dir_io('C');
  110.             break;
  111.         }
  112.  
  113.  
  114.         /* TEXT_IO:                                           */
  115.         /* procedure CREATE(FILE : in out FILE_TYPE;          */
  116.         /*                  MODE : in FILE_MODE := OUT_FILE;  */
  117.         /*                  NAME : in STRING    := "";        */
  118.         /*                  FORM : in STRING    := "");       */
  119.  
  120.     case P_TIO_CREATE:
  121.         {
  122.             open_textio('C');
  123.             break;
  124.         }
  125.  
  126.  
  127.         /*  SEQUENTIAL_IO:                           */
  128.         /*  procedure OPEN(FILE : in out FILE_TYPE;  */
  129.         /*                 MODE : in FILE_MODE;      */
  130.         /*                 NAME : in STRING;         */
  131.         /*                 FORM : in STRING := "");  */
  132.  
  133.     case P_SIO_OPEN:
  134.         {
  135.             open_seq_io('O');
  136.             break;
  137.         }
  138.  
  139.  
  140.         /* DIRECT_IO:                                */
  141.         /* procedure OPEN(FILE : in out FILE_TYPE;   */
  142.         /*                MODE : in FILE_MODE;       */
  143.         /*                NAME : in STRING;          */
  144.         /*                FORM : in STRING := "");   */
  145.  
  146.     case P_DIO_OPEN:
  147.         {
  148.             open_dir_io('O');
  149.             break;
  150.         }
  151.  
  152.  
  153.         /* TEXT_IO:                                  */
  154.         /* procedure OPEN(FILE : in out FILE_TYPE;   */
  155.         /*                MODE : in FILE_MODE;       */
  156.         /*                NAME : in STRING;          */
  157.         /*                FORM : in STRING := "");   */
  158.  
  159.     case P_TIO_OPEN:
  160.         {
  161.             open_textio('O');
  162.             break;
  163.         }
  164.  
  165.  
  166.         /* procedure CLOSE(FILE : in out FILE_TYPE); */
  167.  
  168.     case P_SIO_CLOSE:
  169.     case P_DIO_CLOSE:
  170.     case P_TIO_CLOSE:
  171.         {
  172.             int    *file_ptr;
  173.  
  174.             file_ptr = get_argument_ptr(0);
  175.             filenum = *file_ptr;
  176.             check_file_open();
  177.  
  178.             *file_ptr = 0;
  179.  
  180.             if (operation == P_SIO_CLOSE || operation == P_DIO_CLOSE)
  181.                 close_file();
  182.             else /* operation == P_TIO_CLOSE */
  183.                 close_textio();
  184.             break;
  185.         }
  186.  
  187.         /*  procedure DELETE(FILE : in out FILE_TYPE); */
  188.  
  189.     case P_SIO_DELETE:
  190.     case P_DIO_DELETE:
  191.     case P_TIO_DELETE:
  192.         {
  193.             int    *file_ptr;
  194.  
  195.             file_ptr = get_argument_ptr(0);
  196.             filenum = *file_ptr;
  197.             check_file_open();
  198.  
  199.             strcpy(work_string, IOFNAME);
  200.  
  201.             if (operation == P_SIO_DELETE || P_DIO_DELETE)
  202.                 close_file();
  203.             else /* operation == P_TIO_DELETE */
  204.                 close_textio();
  205. #ifdef vms
  206.             delete(work_string);
  207. #else
  208.             unlink(work_string);
  209. #endif
  210.  
  211.             *file_ptr = 0;
  212.             break;
  213.         }
  214.  
  215.  
  216.         /*  SEQUENTIAL_IO:                                                 */
  217.         /*  procedure RESET(FILE : in out FILE_TYPE; MODE : in FILE_MODE); */
  218.         /*  procedure RESET(FILE : in out FILE_TYPE);                      */
  219.  
  220.     case P_SIO_RESET:
  221.     case P_SIO_RESET_MODE:
  222.         {
  223.             int    newmode;
  224.  
  225.             DISCARD_GENERIC_PARAMETER;
  226.             get_filenum();
  227.             check_file_open();
  228.  
  229.             if (operation == P_SIO_RESET_MODE) {
  230.                 newmode = get_argument_value(2);
  231.             }
  232.             else
  233.                 newmode = IOMODE;
  234.  
  235.             fclose(IOFDESC);
  236.  
  237.             if (newmode == SIO_IN_FILE) {
  238.                 IOFDESC = fopen_bin(IOFNAME, "r");
  239.                 check_opened_ok();
  240.             }
  241.             else {
  242.                 IOFDESC = fopen_bin(IOFNAME, "r+");
  243.                 check_opened_ok();
  244.             }
  245.             IOMODE = newmode;
  246.             break;
  247.         }
  248.  
  249.         /* DIRECT_IO:                                                       */
  250.         /* procedure RESET (FILE : in out FILE_TYPE;  MODE : in FILE_MODE); */
  251.         /* procedure RESET (FILE : in out FILE_TYPE);                       */
  252.  
  253.     case P_DIO_RESET:
  254.     case P_DIO_RESET_MODE:
  255.         {
  256.             int    newmode;
  257.  
  258.             DISCARD_GENERIC_PARAMETER;
  259.             get_filenum();
  260.  
  261.             check_file_open();
  262.  
  263.             if (operation == P_DIO_RESET_MODE)
  264.                 newmode = get_argument_value(2);
  265.             else
  266.                 newmode = IOMODE;
  267.  
  268.             fclose(IOFDESC);
  269.  
  270.             if (newmode == DIO_IN_FILE) {
  271.                 IOFDESC = fopen_bin(IOFNAME, "r");
  272.             }
  273.             else {
  274.                 IOFDESC = fopen_bin(IOFNAME, "r+");
  275.             }
  276.             check_opened_ok();
  277.  
  278.             IOMODE = newmode;
  279.             DPOS = 1;
  280.             break;
  281.         }
  282.  
  283.         /* TEXT_IO:                                                       */
  284.         /* procedure RESET(FILE : in out FILE_TYPE; MODE : in FILE_MODE); */
  285.         /* procedure RESET(FILE : in out FILE_TYPE);                      */
  286.  
  287.     case P_TIO_RESET:
  288.     case P_TIO_RESET_MODE:
  289.         {
  290.             int     newmode;
  291.  
  292.             get_filenum();
  293.             check_file_open();
  294.  
  295.             if (operation == P_TIO_RESET_MODE) {
  296.                 newmode = get_argument_value(2);
  297.  
  298.                 /* Raise MODE_ERROR on attempt to change the mode of the
  299.                  * current default input or output file. */
  300.  
  301.                 if ((filenum == current_in_file || filenum == current_out_file)
  302.                   && newmode != IOMODE) {
  303.                     predef_raise(MODE_ERROR, "Cannot change mode");
  304.                 }
  305.             }
  306.             else
  307.                 newmode = IOMODE;
  308.  
  309.             if (IOMODE == TIO_OUT_FILE) {
  310.  
  311.                 /* Simulate NEW_PAGE unless current page already terminated */
  312.  
  313.                 if (!PAGE_TERMINATED) {
  314.                     if (COL > 1 ||(COL == 1 && LINE == 1)) {
  315.                         put_line();
  316.                     }
  317.                     put_page();
  318.                 }
  319.             }
  320.  
  321.             fclose(IOFDESC);
  322.  
  323.             if (newmode == TIO_IN_FILE) {
  324.                 IOFDESC = fopen_txt(IOFNAME, "r");
  325.                 check_opened_ok();
  326.             }
  327.             else {
  328.                 IOFDESC = fopen_txt(IOFNAME, "r+");
  329.                 check_opened_ok();
  330.                 LINE_LENGTH = 0;
  331.                 PAGE_LENGTH = 0;
  332.             }
  333.  
  334.             IOMODE = newmode;
  335.             CHARS = 0;
  336.             COL = 1;
  337.             LINE = 1;
  338.             PAGE = 1;
  339.             break;
  340.         }
  341.  
  342.         /* function MODE(FILE : in FILE_TYPE) return FILE_MODE; */
  343.  
  344.     case P_SIO_MODE:
  345.     case P_DIO_MODE:
  346.     case P_TIO_MODE:
  347.         {
  348.             get_filenum();
  349.             check_file_open();
  350.             TOSM(2) = IOMODE;
  351.             break;
  352.         }
  353.  
  354.  
  355.         /* function NAME(FILE : in FILE_TYPE) return STRING; */
  356.  
  357.     case P_SIO_NAME:
  358.     case P_DIO_NAME:
  359.     case P_TIO_NAME:
  360.         {
  361.             get_filenum();
  362.             check_file_open();
  363.             return_string(IOFNAME, 2);
  364.             break;
  365.         }
  366.  
  367.  
  368.         /* function FORM(FILE : in FILE_TYPE) return STRING; */
  369.  
  370.     case P_SIO_FORM:
  371.     case P_DIO_FORM:
  372.     case P_TIO_FORM:
  373.         {
  374.             get_filenum();
  375.             check_file_open();
  376.             return_string(IOFORM, 2);
  377.             break;
  378.         }
  379.  
  380.  
  381.         /* function IS_OPEN(FILE : in FILE_TYPE) return BOOLEAN; */
  382.  
  383.     case P_SIO_IS_OPEN:
  384.     case P_DIO_IS_OPEN:
  385.     case P_TIO_IS_OPEN:
  386.         {
  387.             get_filenum();
  388.             TOSM(2) = (filenum != 0);
  389.             break;
  390.         }
  391.  
  392.  
  393.  
  394.         /* 14.2.2  SEQUENTIAL INPUT-OUTPUT */
  395.  
  396.  
  397.         /* procedure READ(FILE : in FILE_TYPE; ITEM : out ELEMENT_TYPE); */
  398.  
  399.     case P_SIO_READ:
  400.         {
  401.             int     *item_tt_ptr;
  402.             int     *item_ptr;
  403.             int     length, lread;
  404.             int     type;
  405.  
  406.             POP_PTR(item_tt_ptr);          /* pop generic type */
  407.  
  408.             /* If the type is an array, then we have an extra entry
  409.                  * on the stack, which is the descriptor for the actual
  410.                  * array value. In this case we want to use the length
  411.                  * from the actual value, rather than from the generic
  412.                  * template. In other cases, the length comes from the
  413.                  * generic template */
  414.  
  415.             type = TYPE(item_tt_ptr);
  416.             if (type == TT_C_ARRAY || type == TT_S_ARRAY ||
  417.                 type == TT_D_ARRAY) {
  418.                 item_tt_ptr = get_argument_ptr(2);
  419.                 item_ptr = get_argument_ptr(4);
  420.             }
  421.             else {
  422.                 item_ptr = get_argument_ptr(2);
  423.             }
  424.  
  425.             length = SIZE(item_tt_ptr);
  426.  
  427.             get_filenum();
  428.  
  429.             check_status(SIO_IN_FILE);
  430.  
  431.             lread = fread(item_ptr,sizeof(int),length,IOFDESC);
  432.             if (lread == 0)
  433.                 predef_raise(END_ERROR, "End of file");
  434.             else if (lread < length)
  435.                 predef_raise(DATA_ERROR, "Wrong length item at end of file");
  436.             break;
  437.         }
  438.  
  439.  
  440.         /* procedure WRITE(FILE : in FILE_TYPE; ITEM : in ELEMENT_TYPE); */
  441.  
  442.     case P_SIO_WRITE:
  443.         {
  444.             int     *item_tt_ptr;
  445.             int     *item_ptr;
  446.             int     length, lwrit;
  447.             int     type;
  448.  
  449.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  450.  
  451.             /* If the type is an array, then we have an extra entry
  452.                  * on the stack, which is the descriptor for the actual
  453.                  * array value. In this case we want to use the length
  454.                  * from the actual value, rather than from the generic
  455.                  * template. In other cases, the length comes from the
  456.                  * generic template */
  457.  
  458.             type = TYPE(item_tt_ptr);
  459.             if (type == TT_C_ARRAY || type == TT_S_ARRAY ||
  460.                 type == TT_D_ARRAY) {
  461.                 item_tt_ptr = get_argument_ptr(2);
  462.                 item_ptr = get_argument_ptr(4);
  463.             }
  464.             else {
  465.                 item_ptr = get_argument_ptr(2);
  466.             }
  467.  
  468.             length = SIZE(item_tt_ptr);
  469.  
  470.             get_filenum();
  471.  
  472.             check_status(SIO_OUT_FILE);
  473.  
  474.             lwrit = fwrite(item_ptr,sizeof(int),length,IOFDESC);
  475.             if (lwrit < length) {
  476.                 predef_raise(END_ERROR, "File full");
  477.             }
  478.             break;
  479.         }
  480.  
  481.  
  482.         /* function END_OF_FILE(FILE : in FILE_TYPE) return BOOLEAN; */
  483.  
  484.     case P_SIO_END_OF_FILE:
  485.         {
  486.             long    curpos, eofpos;
  487.  
  488.             get_filenum();
  489.             check_status(SIO_IN_FILE);
  490.  
  491.             fseek(IOFDESC, 0L, 1);
  492.             curpos = ftell(IOFDESC);
  493.             fseek(IOFDESC, 0L, 2);
  494.             eofpos = ftell(IOFDESC);
  495.             fseek(IOFDESC, curpos, 0);
  496.             TOSM(2) = (curpos == eofpos);
  497.             break;
  498.         }
  499.  
  500.  
  501.         /* 14.2.4  DIRECT INPUT-OUTPUT */
  502.  
  503.  
  504.         /* procedure READ(FILE : in FILE_TYPE; ITEM : out ELEMENT_TYPE);   */
  505.         /* procedure READ(FILE : in FILE_TYPE; ITEM : out ELEMENT_TYPE;    */
  506.         /*                                     FROM : in  POSITIVE_COUNT); */
  507.  
  508.     case P_DIO_READ:
  509.     case P_DIO_READ_FROM:
  510.         {
  511.             int     *item_tt_ptr;
  512.             int     *item_ptr;
  513.             int     type_offset;
  514.             int     from;
  515.             long    newpos;
  516.             int     type;
  517.  
  518.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  519.  
  520.             /* If the type is an array, then we have an extra entry
  521.                  * on the stack, which is the descriptor for the actual
  522.                  * array value. */
  523.  
  524.             type = TYPE(item_tt_ptr);
  525.             if (type == TT_C_ARRAY || type == TT_S_ARRAY || type == TT_D_ARRAY)
  526.             {
  527.                 item_tt_ptr = get_argument_ptr(2);
  528.                 type_offset = 2;
  529.             }
  530.             else type_offset = 0;
  531.  
  532.             item_ptr = get_argument_ptr(2 + type_offset);
  533.  
  534.             get_filenum();
  535.             check_file_open();
  536.  
  537.             if (operation == P_DIO_READ_FROM) {
  538.                 if (type == TT_RECORD) {
  539.                     from = get_argument_value(4);
  540.                 }
  541.                 else {
  542.                     from = get_argument_value(6);
  543.                 }
  544.             }
  545.             else from = DPOS;
  546.  
  547.             if (IOMODE == DIO_OUT_FILE) {
  548.                 predef_raise(MODE_ERROR, "Direct read from OUT file");
  549.             }
  550.  
  551.             if (from > DSIZE) {
  552.                 predef_raise(END_ERROR, "Direct read past end of file");
  553.             }
  554.  
  555.             newpos = (from - 1) * DLENGTH;
  556.             fseek(IOFDESC, newpos, 0);
  557.             fread(item_ptr, 1, DLENGTH, IOFDESC);
  558.  
  559.             DPOS = from + 1;
  560.             break;
  561.         }
  562.  
  563.  
  564.         /* procedure WRITE(FILE : in FILE_TYPE; ITEM : in ELEMENT_TYPE); */
  565.         /* procedure WRITE(FILE : in FILE_TYPE; ITEM : in ELEMENT_TYPE;  */
  566.         /*                                        TO : in POSITIVE_COUNT); */
  567.  
  568.     case P_DIO_WRITE:
  569.     case P_DIO_WRITE_TO:
  570.         {
  571.             int     *item_tt_ptr;
  572.             int     *item_ptr;
  573.             int     type_offset;
  574.             int     to;
  575.             long    newpos;
  576.             int     type;
  577.  
  578.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  579.  
  580.             /* If the type is an array, then we have an extra entry
  581.                  * on the stack, which is the descriptor for the actual
  582.                  * array value. */
  583.  
  584.             type = TYPE(item_tt_ptr);
  585.             if (type == TT_C_ARRAY || type == TT_S_ARRAY || type == TT_D_ARRAY)
  586.             {
  587.                 item_tt_ptr = get_argument_ptr(2);
  588.                 type_offset = 2;
  589.             }
  590.             else type_offset = 0;
  591.  
  592.             item_ptr = get_argument_ptr(2 + type_offset);
  593.             get_filenum();
  594.             check_file_open();
  595.  
  596.             if (operation == P_DIO_WRITE_TO) {
  597.                 to = get_argument_value(4 + type_offset);
  598.             }
  599.             else to = DPOS;
  600.  
  601.             if (IOMODE == DIO_IN_FILE) {
  602.                 predef_raise(MODE_ERROR, "Direct write to an IN file");
  603.             }
  604.  
  605.             newpos = (to - 1) * DLENGTH;
  606.             fseek(IOFDESC, newpos, 0);
  607.             fwrite(item_ptr, 1, DLENGTH, IOFDESC);
  608.  
  609.             DPOS = to + 1;
  610.             if (to > DSIZE) DSIZE = to;
  611.             break;
  612.         }
  613.  
  614.  
  615.         /* procedure SET_INDEX(FILE : in FILE_TYPE; TO : in POSITIVE_COUNT); */
  616.  
  617.     case P_DIO_SET_INDEX:
  618.         {
  619.             get_filenum();
  620.             check_file_open();
  621.  
  622.             DPOS = get_argument_value(2);
  623.             break;
  624.         }
  625.  
  626.  
  627.         /* function INDEX(FILE : in FILE_TYPE) return POSITIVE_COUNT; */
  628.  
  629.     case P_DIO_INDEX:
  630.         {
  631.             get_filenum();
  632.             check_file_open();
  633.  
  634.             TOSM(2) = DPOS;
  635.             break;
  636.         }
  637.  
  638.  
  639.         /* function SIZE(FILE : in FILE_TYPE) return COUNT; */
  640.  
  641.     case P_DIO_SIZE:
  642.         {
  643.             get_filenum();
  644.             check_file_open();
  645.  
  646.             TOSM(2) = DSIZE;
  647.             break;
  648.         }
  649.  
  650.  
  651.         /* function END_OF_FILE(FILE : in FILE_TYPE) return BOOLEAN; */
  652.  
  653.     case P_DIO_END_OF_FILE:
  654.         {
  655.             get_filenum();
  656.             check_file_open();
  657.  
  658.             if (IOMODE == DIO_OUT_FILE) {
  659.                 predef_raise(MODE_ERROR, "Bad mode in direct END_OF_FILE");
  660.             }
  661.  
  662.             TOSM(2) = (DPOS > DSIZE);
  663.             break;
  664.         }
  665.  
  666.  
  667.  
  668.         /* 14.3.2  DEFAULT INPUT AND OUTPUT FILES */
  669.  
  670.  
  671.         /* procedure SET_INPUT(FILE : in FILE_TYPE); */
  672.  
  673.     case P_SET_INPUT:
  674.         {
  675.             get_filenum();
  676.             check_status(TIO_IN_FILE);
  677.  
  678.             current_in_file = filenum;
  679.             /* Save a copy of the current default input file number 
  680.              * which can be checked after the default file is closed.
  681.              */
  682.             current_in_file_saved = filenum;
  683.             break;
  684.         }
  685.  
  686.  
  687.         /* procedure SET_OUTPUT(FILE : in FILE_TYPE); */
  688.  
  689.     case P_SET_OUTPUT:
  690.         {
  691.             get_filenum();
  692.             check_status(TIO_OUT_FILE);
  693.             current_out_file = filenum;
  694.             /* Save a copy of the current default output file number 
  695.              * which can be checked after the default file is closed.
  696.              */
  697.             current_out_file_saved = filenum;
  698.             break;
  699.         }
  700.  
  701.  
  702.         /* function STANDARD_INPUT return FILE_TYPE; */
  703.  
  704.     case P_STANDARD_INPUT:
  705.         {
  706.             int     bse, off, *ptr;
  707.             create(1, &bse, &off, &ptr);
  708.             *ptr = standard_in_file;
  709.             TOSM(1) = bse;
  710.             TOS = off;
  711.             break;
  712.         }
  713.  
  714.  
  715.         /* function STANDARD_OUTPUT return FILE_TYPE; */
  716.  
  717.     case P_STANDARD_OUTPUT:
  718.         {
  719.             int     bse, off, *ptr;
  720.             create(1, &bse, &off, &ptr);
  721.             *ptr = standard_out_file;
  722.             TOSM(1) = bse;
  723.             TOS = off;
  724.             break;
  725.         }
  726.  
  727.  
  728.         /* function CURRENT_INPUT return FILE_TYPE; */
  729.  
  730.     case P_CURRENT_INPUT:
  731.         {
  732.             int     bse, off, *ptr;
  733.             create(1, &bse, &off, &ptr);
  734.             *ptr = current_in_file;
  735.             TOSM(1) = bse;
  736.             TOS = off;
  737.             break;
  738.         }
  739.  
  740.  
  741.         /* function CURRENT_OUTPUT return FILE_TYPE; */
  742.  
  743.     case P_CURRENT_OUTPUT:
  744.         {
  745.             int     bse, off, *ptr;
  746.             create(1, &bse, &off, &ptr);
  747.             *ptr = current_out_file;
  748.             TOSM(1) = bse;
  749.             TOS = off;
  750.             break;
  751.         }
  752.  
  753.  
  754.         /* 14.3.3  SPECIFICATION OF LINE AND PAGE LENGTHS */
  755.  
  756.  
  757.         /* procedure SET_LINE_LENGTH(FILE : in FILE_TYPE; TO : in COUNT); */
  758.         /* procedure SET_LINE_LENGTH(TO : in COUNT);                      */
  759.  
  760.     case P_SET_LINE_LENGTH:
  761.     case P_SET_LINE_LENGTH_FILE:
  762.         {
  763.             get_file_argument_or_default();
  764.             check_status(TIO_OUT_FILE);
  765.  
  766.             LINE_LENGTH = get_argument_value(0 + file_offset);
  767.             break;
  768.         }
  769.  
  770.  
  771.         /* procedure SET_PAGE_LENGTH(FILE : in FILE_TYPE;   TO : in COUNT); */
  772.         /* procedure SET_PAGE_LENGTH(TO : in COUNT);                        */
  773.  
  774.     case P_SET_PAGE_LENGTH:
  775.     case P_SET_PAGE_LENGTH_FILE:
  776.         {
  777.             get_file_argument_or_default();
  778.             check_status(TIO_OUT_FILE);
  779.  
  780.             PAGE_LENGTH = get_argument_value(0 + file_offset);
  781.             break;
  782.         }
  783.  
  784.  
  785.         /* function LINE_LENGTH(FILE : in FILE_TYPE) return COUNT; */
  786.         /* function LINE_LENGTH return COUNT;                      */
  787.  
  788.     case P_LINE_LENGTH:
  789.     case P_LINE_LENGTH_FILE:
  790.         {
  791.             get_file_argument_or_default();
  792.             check_status(TIO_OUT_FILE);
  793.  
  794.             TOSM(0 + file_offset) = LINE_LENGTH;
  795.             break;
  796.         }
  797.  
  798.  
  799.         /* function PAGE_LENGTH(FILE : in FILE_TYPE) return COUNT; */
  800.         /* function PAGE_LENGTH return COUNT;                      */
  801.  
  802.     case P_PAGE_LENGTH:
  803.     case P_PAGE_LENGTH_FILE:
  804.         {
  805.             get_file_argument_or_default();
  806.             check_status(TIO_OUT_FILE);
  807.  
  808.             TOSM(0 + file_offset) = PAGE_LENGTH;
  809.             break;
  810.         }
  811.  
  812.  
  813.         /* 14.3.4  OPERATIONS ON COLUMNS, LINES, AND PAGES */
  814.  
  815.  
  816.         /* procedure NEW_LINE(FILE : in FILE_TYPE;                */
  817.         /*                     SPACING : in POSITIVE_COUNT := 1); */
  818.         /* procedure NEW_LINE(SPACING : in POSITIVE_COUNT := 1);  */
  819.  
  820.     case P_NEW_LINE_FILE:
  821.     case P_NEW_LINE:
  822.         {
  823.             int     spacing, i;
  824.  
  825.             get_file_argument_or_default();
  826.             check_status(TIO_OUT_FILE);
  827.  
  828.             spacing = get_argument_value(0 + file_offset);
  829.  
  830.             for (i = 1; i <= spacing; i++) {
  831.                 put_line();
  832.             }
  833.             break;
  834.         }
  835.  
  836.  
  837.         /* procedure SKIP_LINE(FILE : in FILE_TYPE;               */
  838.         /*                     SPACING : in POSITIVE_COUNT := 1); */
  839.         /* procedure SKIP_LINE(SPACING : in POSITIVE_COUNT := 1); */
  840.  
  841.     case P_SKIP_LINE_FILE:
  842.     case P_SKIP_LINE:
  843.         {
  844.             int     spacing;
  845.             int     i;
  846.  
  847.             get_file_argument_or_default();
  848.             check_status(TIO_IN_FILE);
  849.  
  850.             spacing = get_argument_value(0 + file_offset);
  851.  
  852.             for (i = 1; i <= spacing; i++) {
  853.                 skip_line();
  854.             }
  855.             break;
  856.         }
  857.  
  858.  
  859.         /* function END_OF_LINE(FILE : in FILE_TYPE) return BOOLEAN; */
  860.         /* function END_OF_LINE return BOOLEAN;                      */
  861.  
  862.     case P_END_OF_LINE_FILE:
  863.     case P_END_OF_LINE:
  864.         {
  865.             get_file_argument_or_default();
  866.             check_status(TIO_IN_FILE);
  867.  
  868.             load_look_ahead();
  869.             TOSM(0 + file_offset) = (CHARS == 0 || CHAR1 == LINE_FEED);
  870.             break;
  871.         }
  872.  
  873.  
  874.         /* procedure NEW_PAGE(FILE : in FILE_TYPE); */
  875.         /* procedure NEW_PAGE;                      */
  876.  
  877.     case P_NEW_PAGE_FILE:
  878.     case P_NEW_PAGE:
  879.         {
  880.             get_file_argument_or_default();
  881.             check_status(TIO_OUT_FILE);
  882.  
  883.             if (COL > 1 ||(COL == 1 && LINE == 1)) {
  884.                 put_line();
  885.             }
  886.             put_page();
  887.             break;
  888.         }
  889.  
  890.  
  891.         /* procedure SKIP_PAGE(FILE : in FILE_TYPE); */
  892.         /* procedure SKIP_PAGE;                      */
  893.  
  894.     case P_SKIP_PAGE_FILE:
  895.     case P_SKIP_PAGE:
  896.         {
  897.             get_file_argument_or_default();
  898.             check_status(TIO_IN_FILE);
  899.  
  900.             while(get_char() != PAGE_MARK);
  901.             break;
  902.         }
  903.  
  904.  
  905.         /* function END_OF_PAGE(FILE : in FILE_TYPE) return BOOLEAN; */
  906.         /* function END_OF_PAGE return BOOLEAN;                      */
  907.  
  908.     case P_END_OF_PAGE_FILE:
  909.     case P_END_OF_PAGE:
  910.         {
  911.             int     result;
  912.  
  913.             get_file_argument_or_default();
  914.             check_status(TIO_IN_FILE);
  915.  
  916.             load_look_ahead();
  917.             if (CHARS == 0)
  918.                 result = TRUE;
  919.             else {
  920.                 result = (CHARS > 1 && CHAR1 == LINE_FEED
  921.                   && CHAR2 == PAGE_MARK);
  922.             }
  923.             TOSM(0 + file_offset) = result;
  924.             break;
  925.         }
  926.  
  927.  
  928.         /* function END_OF_FILE(FILE : in FILE_TYPE) return BOOLEAN; */
  929.         /* function END_OF_FILE return BOOLEAN;                      */
  930.  
  931.     case P_TIO_END_OF_FILE:
  932.     case P_TIO_END_OF_FILE_FILE:
  933.         {
  934.             int     result;
  935.  
  936.             get_file_argument_or_default();
  937.             check_status(TIO_IN_FILE);
  938.  
  939.             load_look_ahead();
  940.             if (CHARS == 0)
  941.                 result = TRUE;
  942.             else {
  943.                 result = (CHARS == 2 && CHAR1 == LINE_FEED
  944.                   && CHAR2 == PAGE_MARK);
  945.             }
  946.             TOSM(0 + file_offset) = result;
  947.             break;
  948.         }
  949.  
  950.  
  951.         /* procedure SET_COL(FILE : in FILE_TYPE; TO : in POSITIVE_COUNT); */
  952.         /* procedure SET_COL(TO : in POSITIVE_COUNT);                      */
  953.  
  954.     case P_SET_COL:
  955.     case P_SET_COL_FILE:
  956.         {
  957.             int     to_val;
  958.  
  959.             get_file_argument_or_default();
  960.             to_val = get_argument_value(0 + file_offset);
  961.             check_file_open();
  962.  
  963.             /* SET_COL for file of mode OUT_FILE */
  964.  
  965.             if (IOMODE == TIO_OUT_FILE) {
  966.                 if (BOUNDED_LINE_LENGTH && to_val > LINE_LENGTH)
  967.                     predef_raise(LAYOUT_ERROR, "SET_COL past end of line");
  968.  
  969.                 if (to_val > COL) {
  970.                     put_blanks(to_val - COL);
  971.                     COL = to_val;
  972.                 }
  973.                 else if (to_val < COL) {
  974.                     put_line();
  975.                     put_blanks(to_val - 1);
  976.                     COL = to_val;
  977.                 }
  978.             }
  979.  
  980.             /* SET_COL for file of mode IN_FILE */
  981.  
  982.             else {
  983.                 load_look_ahead();
  984.                 while(COL != to_val || CHAR1 == LINE_FEED || CHAR1 == PAGE_MARK)
  985.                     get_char();
  986.             }
  987.  
  988.             break;
  989.         }
  990.  
  991.  
  992.         /* procedure SET_LINE(FILE : in FILE_TYPE;  TO : in POSITIVE_COUNT); */
  993.         /* procedure SET_LINE(TO   : in POSITIVE_COUNT);                     */
  994.  
  995.     case P_SET_LINE:
  996.     case P_SET_LINE_FILE:
  997.         {
  998.             int     to_val;
  999.             int     i;
  1000.  
  1001.             get_file_argument_or_default();
  1002.             to_val = get_argument_value(0 + file_offset);
  1003.             check_file_open();
  1004.  
  1005.             /* SET_LINE for file of mode OUT_FILE */
  1006.  
  1007.             if (IOMODE == TIO_OUT_FILE) {
  1008.                 if (BOUNDED_PAGE_LENGTH && to_val > PAGE_LENGTH) {
  1009.                     predef_raise(LAYOUT_ERROR, "SET_LINE > PAGE_LENGTH");
  1010.                 }
  1011.  
  1012.                 if (to_val > LINE) {
  1013.                     i = to_val - LINE;
  1014.                     while(i--)
  1015.                         put_line();
  1016.                 }
  1017.                 else if (to_val < LINE) {
  1018.                     if (COL > 1 ||(COL == 1 && LINE == 1))
  1019.                         put_line();
  1020.                     put_page();
  1021.                     i = to_val - 1;
  1022.                     while(i--)
  1023.                         put_line();
  1024.                 }
  1025.             }
  1026.  
  1027.             /* SET_LINE for file of mode IN_FILE */
  1028.  
  1029.             else {
  1030.                 load_look_ahead();
  1031.                 while(LINE != to_val || CHAR1 == PAGE_MARK) {
  1032.                     get_char();
  1033.                 }
  1034.             }
  1035.             break;
  1036.         }
  1037.  
  1038.  
  1039.         /* function COL(FILE : FILE_TYPE)  return POSITIVE_COUNT; */
  1040.         /* function COL return POSITIVE_COUNT;                    */
  1041.  
  1042.     case P_COL:
  1043.     case P_COL_FILE:
  1044.         {
  1045.             get_file_argument_or_default();
  1046.             check_file_open();
  1047.  
  1048.             if (COL > COUNT_LAST) {
  1049.                 predef_raise(LAYOUT_ERROR, "COL > COUNT'LAST");
  1050.             }
  1051.  
  1052.             TOSM(0 + file_offset) = COL;
  1053.             break;
  1054.         }
  1055.  
  1056.  
  1057.         /* function LINE(FILE : FILE_TYPE) return POSITIVE_COUNT; */
  1058.         /* function LINE return POSITIVE_COUNT;                   */
  1059.  
  1060.     case P_LINE:
  1061.     case P_LINE_FILE:
  1062.         {
  1063.             get_file_argument_or_default();
  1064.             check_file_open();
  1065.  
  1066.             if (LINE < 0) {
  1067.                 predef_raise(LAYOUT_ERROR, "LINE > COUNT'LAST");
  1068.             }
  1069.  
  1070.             TOSM(0 + file_offset) = LINE;
  1071.             break;
  1072.         }
  1073.  
  1074.  
  1075.         /* function PAGE(FILE : FILE_TYPE) return POSITIVE_COUNT; */
  1076.         /* function PAGE return POSITIVE_COUNT;                   */
  1077.  
  1078.     case P_PAGE:
  1079.     case P_PAGE_FILE:
  1080.         {
  1081.             get_file_argument_or_default();
  1082.             check_file_open();
  1083.  
  1084.             if (PAGE > COUNT_LAST) {
  1085.                 predef_raise(LAYOUT_ERROR, "PAGE > COUNT'LAST");
  1086.             }
  1087.  
  1088.             TOSM(0 + file_offset) = PAGE;
  1089.             break;
  1090.         }
  1091.  
  1092.  
  1093.  
  1094.         /* 14.3.6  INPUT-OUTPUT OF CHARACTERS AND STRINGS */
  1095.  
  1096.  
  1097.         /* procedure GET(FILE : in FILE_TYPE; ITEM : out CHARACTER); */
  1098.         /* procedure GET(ITEM : out CHARACTER);                      */
  1099.  
  1100.     case P_GET_CHAR_FILE_ITEM:
  1101.     case P_GET_CHAR_ITEM:
  1102.         {
  1103.             int     *item_ptr;
  1104.             int     chr;
  1105.  
  1106.             get_file_argument_or_default();
  1107.             check_status(TIO_IN_FILE);
  1108.  
  1109.             item_ptr = get_argument_ptr(0 + file_offset);
  1110.  
  1111.             for (;;) {
  1112.                 chr = get_char();
  1113.                 if (chr != PAGE_MARK && chr != LINE_FEED)
  1114.                     break;
  1115.             }
  1116.             *item_ptr = chr;
  1117.             break;
  1118.         }
  1119.  
  1120.  
  1121.         /* procedure PUT(FILE : in FILE_TYPE; ITEM : in CHARACTER); */
  1122.         /* procedure PUT(ITEM : in CHARACTER);                      */
  1123.  
  1124.     case P_PUT_CHAR_FILE_ITEM:
  1125.     case P_PUT_CHAR_ITEM:
  1126.         {
  1127.             get_file_argument_or_default();
  1128.             check_status(TIO_OUT_FILE);
  1129.  
  1130.             put_char(get_argument_value(0 + file_offset));
  1131.             break;
  1132.         }
  1133.  
  1134.         /* procedure GET(FILE : in FILE_TYPE; ITEM : out STRING); */
  1135.         /* procedure GET(ITEM : out STRING);                      */
  1136.  
  1137.     case P_GET_STRING_FILE_ITEM:
  1138.     case P_GET_STRING_ITEM:
  1139.         {
  1140.             int    *item_tt_ptr;
  1141.             int     *item_ptr;
  1142.             int     string_size;
  1143.             char    c;
  1144.  
  1145.             get_file_argument_or_default();
  1146.             check_status(TIO_IN_FILE);
  1147.             item_tt_ptr = get_argument_ptr(0 + file_offset);
  1148.             item_ptr    = get_argument_ptr(2 + file_offset);
  1149.  
  1150.             string_size = SIZE(item_tt_ptr);
  1151.  
  1152.             while(string_size) {
  1153.                 c = get_char();
  1154.                 if (c != PAGE_MARK && c != LINE_FEED) {
  1155.                     *item_ptr++ = c;
  1156.                     string_size--;
  1157.                 }
  1158.             }
  1159.             break;
  1160.         }
  1161.  
  1162.  
  1163.         /* procedure PUT(FILE : in FILE_TYPE; ITEM : in STRING); */
  1164.         /* procedure PUT(ITEM : in STRING);                      */
  1165.  
  1166.     case P_PUT_STRING_FILE_ITEM:
  1167.     case P_PUT_STRING_ITEM:
  1168.         {
  1169.             get_file_argument_or_default();
  1170.             check_status(TIO_OUT_FILE);
  1171.             get_string_value(0 + file_offset);
  1172.  
  1173.             put_string(work_string);
  1174.             break;
  1175.         }
  1176.  
  1177.  
  1178.         /*  procedure GET_LINE(FILE : in FILE_TYPE;  ITEM : out STRING;   */
  1179.         /*                                           LAST : out INTEGER); */
  1180.         /*  procedure GET_LINE(ITEM : out STRING; LAST : out INTEGER);    */
  1181.  
  1182.     case P_GET_LINE_FILE:
  1183.     case P_GET_LINE:
  1184.         {
  1185.             int     *item_tt_ptr;
  1186.             int     *item_ptr;
  1187.             int     *last_ptr;
  1188.             int     string_size;
  1189.             int     nstore;
  1190.             char    c;
  1191.  
  1192.             get_file_argument_or_default();
  1193.             check_status(TIO_IN_FILE);
  1194.  
  1195.             item_tt_ptr = get_argument_ptr(0 + file_offset);
  1196.             item_ptr    = get_argument_ptr(2 + file_offset);
  1197.             last_ptr    = get_argument_ptr(4 + file_offset);
  1198.  
  1199.             string_size = SIZE(item_tt_ptr);
  1200.             if (string_size < 0) string_size = 0;
  1201.  
  1202.             nstore = 0;
  1203.             for (;;) {
  1204.                 load_look_ahead();
  1205.                 if (nstore == string_size) break;
  1206.                 if (CHAR1 == LINE_FEED) {
  1207.                     skip_line();
  1208.                     break;
  1209.                 }
  1210.                 c = get_char();
  1211.                 *item_ptr++ = c;
  1212.                 nstore ++;
  1213.             }
  1214.  
  1215.             /* set LAST value */
  1216.  
  1217.             *last_ptr = nstore + string_offset(item_tt_ptr) - 1;
  1218.             break;
  1219.         }
  1220.  
  1221.  
  1222.         /* procedure PUT_LINE(FILE : in FILE_TYPE; ITEM : in STRING); */
  1223.         /* procedure PUT_LINE(ITEM : in STRING);                      */
  1224.  
  1225.     case P_PUT_LINE_FILE:
  1226.     case P_PUT_LINE:
  1227.         {
  1228.             get_file_argument_or_default();
  1229.             check_status(TIO_OUT_FILE);
  1230.  
  1231.             get_string_value(0 + file_offset);
  1232.             put_string(work_string);
  1233.             put_line();
  1234.             break;
  1235.         }
  1236.  
  1237.  
  1238.         /* 14.3.7  INPUT-OUTPUT FOR INTEGER TYPES */
  1239.  
  1240.  
  1241.         /* type NUM is range <>;                                        */
  1242.         /* procedure GET(FILE : in FILE_TYPE;  ITEM : out NUM;         */
  1243.         /*                                      WIDTH : in FIELD := 0); */
  1244.         /* procedure GET(ITEM : out NUM;  WIDTH : in FIELD := 0);      */
  1245.  
  1246.     case P_GET_INTEGER_FILE_ITEM:
  1247.     case P_GET_INTEGER_ITEM:
  1248.         {
  1249.             int     *item_tt_ptr;
  1250.             int     *item_ptr;
  1251.             int     width;
  1252.  
  1253.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1254.  
  1255.             get_file_argument_or_default();
  1256.             check_status(TIO_IN_FILE);
  1257.  
  1258.             item_ptr = get_argument_ptr(0 + file_offset);
  1259.             width = get_argument_value(4 + file_offset);
  1260.  
  1261.             *item_ptr = scan_integer(item_tt_ptr, width);
  1262.             break;
  1263.         }
  1264.  
  1265.  
  1266.         /* procedure PUT(FILE  : in FILE_TYPE;                     */
  1267.         /*                ITEM  : in NUM;                          */
  1268.         /*                WIDTH : in FIELD       := DEFAULT_WIDTH; */
  1269.         /*                BASE  : in NUMBER_BASE := DEFAULT_BASE); */
  1270.  
  1271.         /* procedure PUT(ITEM  : in NUM;                           */
  1272.         /*               WIDTH : in FIELD       := DEFAULT_WIDTH;  */
  1273.         /*               BASE  : in NUMBER_BASE := DEFAULT_BASE);  */
  1274.  
  1275.     case P_PUT_INTEGER_FILE_ITEM:
  1276.     case P_PUT_INTEGER_ITEM:
  1277.         {
  1278.             int     item, width, a_base;
  1279.  
  1280.             DISCARD_GENERIC_PARAMETER;
  1281.  
  1282.             get_file_argument_or_default();
  1283.             check_status(TIO_OUT_FILE);
  1284.  
  1285.             item = get_argument_value(0 + file_offset);
  1286.             width = get_argument_value(2 + file_offset);
  1287.             a_base = get_argument_value(4 + file_offset);
  1288.  
  1289.             image_integer(item, a_base);
  1290.             put_buffer(work_string, width, 'L');
  1291.             break;
  1292.         }
  1293.  
  1294.  
  1295.         /* procedure
  1296.          *   GET(FROM : in STRING; ITEM : out NUM; LAST : out POSITIVE);
  1297.          */
  1298.  
  1299.     case P_GET_INTEGER_STRING:
  1300.         {
  1301.             int     *item_tt_ptr;
  1302.             int     *from_tt_ptr;
  1303.             int     *item_ptr;
  1304.             int     *last_ptr;
  1305.             int     last;
  1306.  
  1307.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1308.  
  1309.             get_string_value(0);
  1310.             from_tt_ptr = get_argument_ptr(0);
  1311.             item_ptr    = get_argument_ptr(4);
  1312.             last_ptr    = get_argument_ptr(8);
  1313.  
  1314.             *item_ptr = scan_integer_string(item_tt_ptr, &last);
  1315.  
  1316.             last += string_offset(from_tt_ptr) ;
  1317.             *last_ptr = last;
  1318.             break;
  1319.         }
  1320.  
  1321.  
  1322.         /* procedure PUT(TO   : out STRING;                       */
  1323.         /*               ITEM : in  NUM;                          */
  1324.         /*               BASE : in  NUMBER_BASE := DEFAULT_BASE); */
  1325.  
  1326.     case P_PUT_INTEGER_STRING:
  1327.         {
  1328.             int     *to_tt_ptr;
  1329.             int     *to_ptr;
  1330.             int     item, a_base;
  1331.             int     string_size, slength;
  1332.             char    *c;
  1333.  
  1334.             DISCARD_GENERIC_PARAMETER;
  1335.             to_tt_ptr = get_argument_ptr(0);
  1336.             to_ptr    = get_argument_ptr(2);
  1337.             item      = get_argument_value(4);
  1338.             a_base    = get_argument_value(6);
  1339.  
  1340.             string_size = SIZE(to_tt_ptr);
  1341.  
  1342.             image_integer(item, a_base);
  1343.             slength = strlen(work_string);
  1344.  
  1345.             if (slength > string_size) {
  1346.                 predef_raise(LAYOUT_ERROR, "String too long");
  1347.             }
  1348.  
  1349.             c = work_string;
  1350.             while(string_size-- > slength) *to_ptr++ = ' ';
  1351.             while(slength--) *to_ptr++ = *c++;
  1352.             break;
  1353.         }
  1354.  
  1355.  
  1356.         /* 14.3.8  INPUT-OUTPUT FOR REAL TYPES */
  1357.  
  1358.  
  1359.         /* type NUM is digits <>;                                      */
  1360.         /* procedure GET(FILE : in FILE_TYPE;  ITEM  : out NUM;        */
  1361.         /*                                     WIDTH : in FIELD := 0); */
  1362.         /* procedure GET(ITEM : out NUM;  WIDTH : in FIELD := 0);      */
  1363.  
  1364.     case P_GET_FLOAT_FILE_ITEM:
  1365.     case P_GET_FLOAT_ITEM:
  1366.         {
  1367.             int     *item_tt_ptr;
  1368.             int     *item_ptr;
  1369.             int     width;
  1370.             float   fval;
  1371.  
  1372.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1373.  
  1374.             get_file_argument_or_default();
  1375.             check_status(TIO_IN_FILE);
  1376.  
  1377.             item_ptr = get_argument_ptr(0 + file_offset);
  1378.             width  = get_argument_value(4 + file_offset);
  1379.  
  1380.             fval = scan_float(item_tt_ptr, width);
  1381.  
  1382.             *((float *)(item_ptr)) = fval;
  1383.             break;
  1384.         }
  1385.  
  1386.         /* procedure PUT(FILE     : in FILE_TYPE;             */
  1387.         /*               ITEM     : in NUM;                   */
  1388.         /*               FORE     : in FIELD := DEFAULT_FORE; */
  1389.         /*               AFT      : in FIELD := DEFAULT_AFT;  */
  1390.         /*               EXP      : in FIELD := DEFAULT_EXP); */
  1391.  
  1392.         /* procedure PUT(ITEM     : in NUM;                   */
  1393.         /*               FORE     : in FIELD := DEFAULT_FORE; */
  1394.         /*               AFT      : in FIELD := DEFAULT_AFT;  */
  1395.         /*               EXP      : in FIELD := DEFAULT_EXP); */
  1396.  
  1397.     case P_PUT_FLOAT_FILE_ITEM:
  1398.     case P_PUT_FLOAT_ITEM:
  1399.         {
  1400.             int     fore, aft, expnt;
  1401.             float   fitem;
  1402.  
  1403.             DISCARD_GENERIC_PARAMETER;
  1404.  
  1405.             get_file_argument_or_default();
  1406.             check_status(TIO_OUT_FILE);
  1407.  
  1408.             fitem = get_float_argument_value(0 + file_offset);
  1409.             fore  = get_argument_value(2 + file_offset);
  1410.             aft   = get_argument_value(4 + file_offset);
  1411.             expnt = get_argument_value(6 + file_offset);
  1412.  
  1413.             image_float(fitem, fore, MAX(aft, 1), expnt);
  1414.             put_buffer(work_string,0,'L');
  1415.             break;
  1416.         }
  1417.  
  1418.  
  1419.         /* procedure
  1420.          *   GET(FROM : in STRING; ITEM : out NUM; LAST : out POSITIVE);
  1421.          */
  1422.  
  1423.     case P_GET_FLOAT_STRING:
  1424.         {
  1425.             int     *item_tt_ptr;
  1426.             int     *from_tt_ptr;
  1427.             int     *item_ptr;
  1428.             int     *last_ptr;
  1429.             int     last;
  1430.             float   fval;
  1431.  
  1432.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1433.  
  1434.             get_string_value(0);
  1435.             from_tt_ptr = get_argument_ptr(0);
  1436.             item_ptr =    get_argument_ptr(4);
  1437.             last_ptr =    get_argument_ptr(8);
  1438.  
  1439.             fval = scan_float_string(item_tt_ptr, &last);
  1440.             *((float *)(item_ptr)) = fval;
  1441.             last += string_offset(from_tt_ptr) ;
  1442.             *last_ptr = last;
  1443.             break;
  1444.         }
  1445.  
  1446.  
  1447.         /* procedure PUT(TO   : out STRING;               */
  1448.         /*               ITEM : in NUM;                   */
  1449.         /*               AFT  : in FIELD := DEFAULT_AFT;  */
  1450.         /*               EXP  : in FIELD := DEFAULT_EXP); */
  1451.  
  1452.     case P_PUT_FLOAT_STRING:
  1453.         {
  1454.             int     *to_tt_ptr;
  1455.             int     *to_ptr;
  1456.             int     aft, expnt;
  1457.             int     string_size, slength;
  1458.             float   fitem;
  1459.             char    *c;
  1460.  
  1461.             DISCARD_GENERIC_PARAMETER;
  1462.  
  1463.             to_tt_ptr = get_argument_ptr(0);
  1464.             to_ptr  =   get_argument_ptr(2);
  1465.             fitem   = get_float_argument_value(4);
  1466.             aft     = get_argument_value(6);
  1467.             expnt   = get_argument_value(8);
  1468.  
  1469.             image_float(fitem, 0, MAX(aft, 1), expnt);
  1470.             slength = strlen(work_string);
  1471.  
  1472.             string_size = SIZE(to_tt_ptr);
  1473.             if (slength > string_size) {
  1474.                 predef_raise(LAYOUT_ERROR, "String too long");
  1475.             }
  1476.  
  1477.             c = work_string;
  1478.             while(string_size-- > slength) {
  1479.                 *to_ptr++ = ' ';
  1480.             }
  1481.             while(slength--) {
  1482.                 *to_ptr++ = *c++;
  1483.             }
  1484.             break;
  1485.         }
  1486.  
  1487.  
  1488.         /* type NUM is delta <>;                                       */
  1489.         /* procedure GET(FILE : in FILE_TYPE;  ITEM : out NUM;         */
  1490.         /*                                     WIDTH : in FIELD := 0); */
  1491.         /* procedure GET(ITEM : out NUM;  WIDTH : in FIELD := 0);      */
  1492.  
  1493.     case P_GET_FIXED_FILE_ITEM:
  1494.     case P_GET_FIXED_ITEM:
  1495.         {
  1496.             int     *item_tt_ptr;
  1497.             int     *item_ptr;
  1498.             int     width;
  1499.  
  1500.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1501.  
  1502.             get_file_argument_or_default();
  1503.             check_status(TIO_IN_FILE);
  1504.  
  1505.             item_ptr = get_argument_ptr(0 + file_offset);
  1506.             width = get_argument_value(4 + file_offset);
  1507.  
  1508.             check_status(TIO_IN_FILE);
  1509.  
  1510.             *((long *)(item_ptr)) = scan_fixed(item_tt_ptr, width);
  1511.             break;
  1512.         }
  1513.  
  1514.  
  1515.         /* procedure PUT(FILE   : in FILE_TYPE;              */
  1516.         /*               ITEM   : in NUM;                    */
  1517.         /*               FORE   : in FIELD := DEFAULT_FORE;  */
  1518.         /*               AFT    : in FIELD := DEFAULT_AFT;   */
  1519.         /*               EXP    : in FIELD := DECIMAL_EXP);  */
  1520.  
  1521.         /* procedure PUT(ITEM   : in NUM;                    */
  1522.         /*               FORE   : in FIELD := DEFAULT_FORE;  */
  1523.         /*               AFT    : in FIELD := DEFAULT_AFT;   */
  1524.         /*               EXP    : in FIELD := DEFAULT_EXP);  */
  1525.  
  1526.     case P_PUT_FIXED_FILE_ITEM:
  1527.     case P_PUT_FIXED_ITEM:
  1528.         {
  1529.             int     *item_tt_ptr;
  1530.             long    item;
  1531.             int     fore, aft, expnt;
  1532.  
  1533.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1534.  
  1535.             get_file_argument_or_default();
  1536.             check_status(TIO_OUT_FILE);
  1537.  
  1538.             item = get_long_argument_value(0 + file_offset);
  1539.             fore  = get_argument_value(2 + file_offset);
  1540.             aft   = get_argument_value(4 + file_offset);
  1541.             expnt = get_argument_value(6 + file_offset);
  1542.  
  1543.             image_fixed(item, item_tt_ptr, MAX(fore, 1), MAX(aft, 1), expnt);
  1544.             put_buffer(work_string,0,'L');
  1545.             break;
  1546.         }
  1547.  
  1548.  
  1549.         /* procedure
  1550.          *   GET(FROM : in STRING; ITEM : out NUM; LAST : out POSITIVE);
  1551.          */
  1552.  
  1553.     case P_GET_FIXED_STRING:
  1554.         {
  1555.             int     *item_tt_ptr;
  1556.             int     *from_tt_ptr;
  1557.             int     *item_ptr;
  1558.             int     *last_ptr;
  1559.             int     last;
  1560.  
  1561.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1562.  
  1563.             get_string_value(0);
  1564.             from_tt_ptr = get_argument_ptr(0);
  1565.             item_ptr = get_argument_ptr(4);
  1566.             last_ptr = get_argument_ptr(8);
  1567.  
  1568.             *((long *)(item_ptr)) = scan_fixed_string(item_tt_ptr, &last);
  1569.  
  1570.             last += string_offset(from_tt_ptr)  ;
  1571.             *last_ptr = last;
  1572.             break;
  1573.         }
  1574.  
  1575.  
  1576.         /* procedure PUT(TO   : out STRING;               */
  1577.         /*               ITEM : in NUM;                   */
  1578.         /*               AFT  : in FIELD := DEFAULT_AFT;  */
  1579.         /*               EXP  : in FIELD := DEFAULT_EXP); */
  1580.  
  1581.     case P_PUT_FIXED_STRING:
  1582.         {
  1583.             int     *item_tt_ptr;
  1584.             int     *to_tt_ptr;
  1585.             int     *to_ptr;
  1586.             long    item;
  1587.             int     aft, expnt;
  1588.             char    *c;
  1589.             int     string_size, slength;
  1590.  
  1591.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1592.  
  1593.             to_tt_ptr = get_argument_ptr(0);
  1594.             to_ptr    = get_argument_ptr(2);
  1595.             item = get_long_argument_value(4);
  1596.             aft   = get_argument_value(6);
  1597.             expnt = get_argument_value(8);
  1598.  
  1599.             image_fixed(item, item_tt_ptr, 1, MAX(aft, 1), expnt);
  1600.             string_size = SIZE(to_tt_ptr);
  1601.             slength = strlen(work_string);
  1602.  
  1603.             if (slength > string_size) {
  1604.                 predef_raise(LAYOUT_ERROR, "String too long");
  1605.             }
  1606.  
  1607.             c = work_string;
  1608.             while(string_size-- > slength)
  1609.                 *to_ptr++ = ' ';
  1610.             while(slength--)
  1611.                 *to_ptr++ = *c++;
  1612.             break;
  1613.         }
  1614.  
  1615.  
  1616.         /* type ENUM is(<>);                                     */
  1617.         /* procedure GET(FILE : in FILE_TYPE;  ITEM : out ENUM); */
  1618.         /* procedure GET(ITEM : out ENUM);                       */
  1619.  
  1620.     case P_GET_ENUM_FILE_ITEM:
  1621.     case P_GET_ENUM_ITEM:
  1622.         {
  1623.             int     *item_tt_ptr;
  1624.             int     *item_ptr;
  1625.  
  1626.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1627.  
  1628.             get_file_argument_or_default();
  1629.             check_status(TIO_IN_FILE);
  1630.  
  1631.             item_ptr = get_argument_ptr(0 + file_offset);
  1632.             scan_enum();
  1633.  
  1634.             /*  Check to see if the identifier or character literal read */
  1635.             /*  corresponds to a value of the given enumeration subtype. */
  1636.  
  1637.             *item_ptr = enum_ord(item_tt_ptr, -1, DATA_ERROR);
  1638.             break;
  1639.         }
  1640.  
  1641.  
  1642.         /* procedure PUT(FILE  : in FILE_TYPE;                    */
  1643.         /*               ITEM  : in ENUM;                         */
  1644.         /*               WIDTH : in FIELD    := DEFAULT_WIDTH;    */
  1645.         /*               SET   : in TYPE_SET := DEFAULT_SETTING); */
  1646.  
  1647.         /* procedure PUT(ITEM  : in ENUM;                         */
  1648.         /*               WIDTH : in FIELD    := DEFAULT_WIDTH;    */
  1649.         /*               SET   : in TYPE_SET := DEFAULT_SETTING); */
  1650.  
  1651.     case P_PUT_ENUM_FILE_ITEM:
  1652.     case P_PUT_ENUM_ITEM:
  1653.         {
  1654.             int     *item_tt_ptr;
  1655.             int     item, width, setting;
  1656.             char    *c;
  1657.  
  1658.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1659.  
  1660.             get_file_argument_or_default();
  1661.             check_status(TIO_OUT_FILE);
  1662.  
  1663.             item    = get_argument_value(0 + file_offset);
  1664.             width   = get_argument_value(2 + file_offset);
  1665.             setting = get_argument_value(4 + file_offset);
  1666.  
  1667.             image_enum(item, item_tt_ptr);
  1668.             if (setting == LOWER_CASE && *work_string != QUOTE) {
  1669.                 for (c = work_string; *c; c++)
  1670.                     if ('A' <= *c && *c <= 'Z') *c += 32;
  1671.             }
  1672.             put_buffer(work_string, width, 'T');
  1673.             break;
  1674.         }
  1675.  
  1676.  
  1677.         /* procedure
  1678.          *    GET(FROM : in STRING; ITEM : out ENUM; LAST : out POSITIVE);
  1679.          */
  1680.  
  1681.     case P_GET_ENUM_STRING:
  1682.         {
  1683.             int     *item_tt_ptr;
  1684.             int     *from_tt_ptr;
  1685.             int     *item_ptr;
  1686.             int     *last_ptr;
  1687.             int     last;
  1688.  
  1689.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1690.  
  1691.             get_string_value(0);
  1692.             from_tt_ptr = get_argument_ptr(0);
  1693.             item_ptr    = get_argument_ptr(4);
  1694.             last_ptr    = get_argument_ptr(8);
  1695.  
  1696.             scan_enum_string(&last);
  1697.  
  1698.             /*  Check to see if the identifier or character literal read */
  1699.             /*  corresponds to a value of the given enumeration subtype. */
  1700.  
  1701.             *item_ptr = enum_ord(item_tt_ptr, -1,  DATA_ERROR);
  1702.             last += string_offset(from_tt_ptr) ;
  1703.             *last_ptr = last;
  1704.             break;
  1705.         }
  1706.  
  1707.  
  1708.         /* procedure PUT(TO   : out STRING;                      */
  1709.         /*               ITEM : in ENUM;                         */
  1710.         /*               SET  : in TYPE_SET := DEFAULT_SETTING); */
  1711.  
  1712.     case P_PUT_ENUM_STRING:
  1713.         {
  1714.             int     *item_tt_ptr;
  1715.             int     *to_ptr;
  1716.             int     *to_tt_ptr;
  1717.             int     string_size, slength;
  1718.             int     item;
  1719.             int     setting;
  1720.             char    *c;
  1721.  
  1722.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1723.  
  1724.             to_tt_ptr = get_argument_ptr(0);
  1725.             to_ptr    = get_argument_ptr(2);
  1726.             item    = get_argument_value(4);
  1727.             setting = get_argument_value(6);
  1728.  
  1729.             image_enum(item, item_tt_ptr);
  1730.             if (setting == LOWER_CASE && *work_string != QUOTE) {
  1731.                 for (c = work_string; *c; c++)
  1732.                     if ('A' <= *c && *c <= 'Z') *c += 32;
  1733.             }
  1734.  
  1735.             string_size = SIZE(to_tt_ptr);
  1736.             slength = strlen(work_string);
  1737.  
  1738.             if (slength > string_size) {
  1739.                 predef_raise(LAYOUT_ERROR, "String too long");
  1740.             }
  1741.  
  1742.             to_ptr += string_size;
  1743.             c = work_string + slength;
  1744.             while(string_size-- > slength) {
  1745.                 *--to_ptr = ' ';
  1746.             }
  1747.             while(slength--) {
  1748.                 *--to_ptr = *--c;
  1749.             }
  1750.             break;
  1751.         }
  1752.  
  1753.  
  1754.         /* 9.6  CALENDAR */
  1755.  
  1756.     case P_CLOCK:
  1757.     case P_YEAR:
  1758.     case P_MONTH:
  1759.     case P_DAY:
  1760.     case P_SECONDS:
  1761.     case P_SPLIT:
  1762.     case P_TIME_OF:
  1763.     case P_ADD_TIME_DUR:
  1764.     case P_ADD_DUR_TIME:
  1765.     case P_SUB_TIME_DUR:
  1766.     case P_SUB_TIME_TIME:
  1767.     case P_LT_TIME:
  1768.     case P_LE_TIME:
  1769.     case P_GT_TIME:
  1770.     case P_GE_TIME:
  1771.         {
  1772.             calendar();
  1773.             break;
  1774.         }
  1775.  
  1776.  
  1777.     default:
  1778.         predef_raise(SYSTEM_ERROR, "Unknown PREDEF operation");
  1779.     }
  1780. }
  1781.  
  1782.  
  1783. /* PREDEF_RAISE */
  1784.  
  1785. /* This procedure raises a specified exception, and then exits from the
  1786.  * PREDEF package completely by unwinding the stack to the top level
  1787.  */
  1788.  
  1789. void predef_raise(int exception, char *msg)            /*;predef_raise*/
  1790. {
  1791.     raise(exception, msg);
  1792.     longjmp(raise_env, 1);
  1793. }
  1794.  
  1795. static int string_offset(int *a_ptr)            /*;string_offset*/
  1796. {
  1797.     if (TYPE(a_ptr) == TT_S_ARRAY) {
  1798.         value = S_ARRAY(a_ptr) -> salow ;
  1799.     }
  1800.     else {
  1801.         bse   = ARRAY(a_ptr)->index1_base ;
  1802.         off   = ARRAY(a_ptr)->index1_offset ;
  1803.         ptr1  = ADDR(bse, off) ;
  1804.         value = I_RANGE(ptr1)->ilow ;
  1805.     }
  1806.     return value;
  1807. }
  1808.